(in-package :lilu-app)

;;;
;;; application
;;;

(defclass application ()
  ((name :initarg :name
         :reader application-name)
   (pretty-name :initarg :pretty-name
                :accessor application-pretty-name
                :initform nil)
   (home-page :initarg :home-page
              :accessor application-home-page
              :initform nil)
   (tags :initarg :tags
         :initform nil
         :reader application-tags)
   (system-name :initarg :system-name
                :accessor application-system-name
                :initform nil)
   (debug-system-p :initarg :debug-system-p
                   :accessor application-debug-system-p
                   :initform nil)
   (%installed-p)
   (%loaded-p)
   (%version)
   (configured-p :accessor application-configured-p
                 :initform nil)))

(defmethod initialize-instance :after ((application application) &rest initargs)
  (declare (ignore initargs))
  (with-slots (name pretty-name) application
    (setf name (string name))
    (unless pretty-name
      (setf pretty-name name))))

;;; print-object
(defmethod print-object ((obj application) stream)
   (print-unreadable-object (obj stream :type t :identity t)
     (princ (application-name obj) stream)
     (princ (application-tags obj) stream)))

(defgeneric application-installed-p (app &key force-p))

(defmethod application-installed-p :around ((app application) &key force-p)
  (if (and (slot-boundp app '%installed-p) (not force-p))
      (slot-value app '%installed-p)
      (setf (slot-value app '%installed-p) (call-next-method))))

(defmethod application-installed-p ((application application) &key force-p)
  (declare (ignore force-p))
  (with-slots (system-name) application
    (if system-name
        (handler-case
            (asdf:find-system system-name)
          (asdf/find-component:missing-component (condition)
            (declare (ignore condition))
            nil))
        t)))

(defgeneric application-loaded-p (app &key force-p))

(defmethod application-loaded-p :around ((app application) &key force-p)
  (if (and (slot-boundp app '%loaded-p) (not force-p))
      (slot-value app '%loaded-p)
      (setf (slot-value app '%loaded-p) (call-next-method))))

(defmethod application-loaded-p ((application application) &key force-p)
  (declare (ignore force-p))
  (with-slots (system-name) application
    (if system-name
        (handler-case
            (member
             (asdf:coerce-name (asdf:find-system system-name))
             (asdf:already-loaded-systems))
          (asdf/find-component:missing-component (condition)
            (declare (ignore condition))
            nil))
        t)))

(defgeneric install-application (application &optional force-p))

(defmethod install-application :around ((application application) &optional (force-p nil))
  (with-slots (%installed-p %loaded-p system-name) application
    (when (or force-p (not (application-installed-p application)))
      (call-next-method)
      (setf %installed-p t
            %loaded-p nil))))

(defmethod install-application ((application application) &optional force-p)
  (declare (ignore force-p))
  (with-slots (name system-name) application
    (if system-name
        (handler-case
            (ql:quickload system-name)
          (ql:system-not-found ()
            (warn "System ~A non found in quicklisp" name)))
        (warn "System name for ~A undefined" name))))

(defgeneric load-application (application &optional force-p))

(defmethod load-application :around ((application application) &optional (force-p nil))
  (when (or force-p (not (application-loaded-p application)))
    (install-application application)
    (with-slots (%loaded-p configured-p) application
      (call-next-method)
      (setf %loaded-p t)
      (setf configured-p nil))))

(defmethod load-application ((application application) &optional force-p)
  (declare (ignore force-p))
  (with-slots (name system-name debug-system-p) application
    (if system-name
        (if debug-system-p
            (asdf:operate 'asdf:load-source-op system-name :force-not t)
            (asdf:require-system system-name))
        (warn "System name for ~A undefined" name))))

(defgeneric application-version (app &key force-p))

(defmethod application-version :around ((app application) &key force-p)
  (if (and (slot-boundp app '%version) (not force-p))
      (slot-value app '%version)
      (setf (slot-value app '%version) (call-next-method))))

(defmethod application-version ((application application) &key force-p)
  (declare (ignore force-p))
  (with-slots (system-name) application
    (if system-name
        (asdf:component-version (asdf:find-system system-name))
        nil)))

(defgeneric configure-application (application &optional force-p))

(defmethod configure-application ((application application) &optional (force-p nil))
  (declare (ignore application force-p)))

(defvar *application*)
(defmethod configure-application :before ((application application)
                                          &optional force-p)
  (declare (ignore force-p))
  (flet ((config-file-relative-pathname (name)
           (format nil "./config/~a.lisp" (string-downcase name))))
    (with-slots (name) application
      (let ((config-file (lilu-config:find-config-file
                          (config-file-relative-pathname name) nil)))
        (if config-file
            (let ((*application* application))
              (load config-file))
            (warn "Config file (~A) for ~A not found"
                  (config-file-relative-pathname name)
                  name))))))

(defmethod configure-application :around ((application application) &optional (force-p nil))
  (load-application application)
  (with-slots (configured-p) application
    (when (or force-p (not configured-p))
      (call-next-method)
      (setf configured-p t))))

;;;
;;; applications
;;;

(defvar *name->application* (make-hash-table :test #'equal))
(defvar *tag->applications* (make-hash-table))

(defun register-application (application)
  (assert (typep application 'application))
  (let ((old-app (find-application (application-name application) nil nil)))
    (when old-app
      (unregister-application old-app)))
  (setf (gethash (application-name application) *name->application*)
        application)
  (dolist (tag (application-tags application))
    (setf (gethash tag *tag->applications*)
          (cons application (gethash tag *tag->applications*))))
  application)

(defun unregister-application (application)
  (assert (typep application 'application))
  (setf (gethash (application-name application) *name->application*)
        nil)
  (dolist (tag (application-tags application))
    (setf (gethash tag *tag->applications*)
          (remove application (gethash tag *tag->applications*)))))

(defun find-application (application-designator &optional tag error-p)
  (let ((name (typecase application-designator
                (application (return-from find-application application-designator))
                (string application-designator)
                (symbol (symbol-name application-designator)))))
    (let ((app (gethash name *name->application*)))
      (if app
          (if tag
              (if (member tag (application-tags app))
                  app
                  (when error-p
                    (error "application ~A tagged ~A not found" application-designator tag)))
              app)
          (when error-p
            (error "application ~A (tagged ~A) not found" application-designator tag))))))

(defun find-applications (tag &optional installed-p)
  (let ((apps (gethash tag *tag->applications*)))
    (if installed-p
        (loop for app in apps
              when (lilu-app:application-installed-p app)
                collect app)
        apps)))

(defun registered-applications ()
  (append (loop for v being each hash-value of *name->application*
                collect v)))

(defun unregister-all-applications (tag)
  (dolist (app (gethash tag *tag->applications*))
    (unregister-application app)))

(defun list-all-applications (tag &optional installed-p)
  (loop for app in (lilu-app:find-applications tag)
        when (or (not installed-p) (lilu-app:application-installed-p app))
          collect (lilu-app:application-name app)))

(defun application-file-relative-pathname (name)
  (format nil "./apps/~a.lisp" (string-downcase name)))

(defgeneric application-file (application))

(defmethod application-file ((application application))
  (with-slots (name) application
    (lilu-config:find-config-file (application-file-relative-pathname name) nil)))

(defun discover-application (name &optional force-p)
  (let ((application (find-application name nil nil)))
    (when (or force-p (null application))
      (let ((application-file
              (application-file-relative-pathname name)))
	      (when application-file
	        (load (lilu-config:find-config-file application-file))))))
  (find-application name))

(defun discover-applications (&optional force-p)
  (dolist (file (lilu-config:find-config-files "./apps"))
    (discover-application (pathname-name file) force-p)))


(defun launch-application (application run-fn &rest args
                           &key error-p callback-fn &allow-other-keys)
  (flet ((run ()
           (let  ((res (apply run-fn application
                              (alexandria:remove-from-plist args :callback-fn))))
             (when callback-fn
               (funcall callback-fn application args res)))
           #+nil(handler-bind ((error #'(lambda (condition)
                                     (unless error-p
                                       (warn "~A~%" condition)
                                       (return-from run)))))
             (let  ((res (apply run-fn application
                                (alexandria:remove-from-plist args :callback-fn))))
               (when callback-fn
                 (funcall callback-fn application args res))))))
    (with-slots (name) application
      (bt:make-thread #'run :name name))))



;;;
;;; debugger
;;;

(defclass simple-debugger-application-mixin ()
  ((debugger-hook :initarg :debugger-hook)))

;;;
;;; common lisp
;;;

(defclass cl-application-mixin ()
  ((git-repo :initarg :git-repo
             :accessor application-git-repo
             :initform nil)))

(defmethod install-application ((application cl-application-mixin) &optional force-p)
  (declare (ignore force-p))
  (call-next-method)
  (unless (application-installed-p application :force-p t)
    (with-slots (name system-name git-repo) application
      (if (and system-name git-repo)
          (let ((cur-dir (uiop/os:getcwd)))
            (uiop/os:chdir (first ql:*local-project-directories*))
            (uiop/run-program:run-program
             (list "git" "clone" git-repo)
             :force-shell t :output t :error-output t)
            (uiop/os:chdir cur-dir)
            (ql:quickload system-name))
          (warn "Git repository for ~A undefined" name)))))

;;;
;;;
;;;

(defclass simple-cl-application-mixin (cl-application-mixin)
  ((entry-fn :initarg :entry-fn
             :accessor application-entry-fn
             :initform nil)))

;;;
;;; program mixin
;;;

(defclass program-application-mixin ()
  ((program :initarg :program)
   (version-option :initarg :version-option)
   (version-script :initarg :version-script)))

(defmethod application-installed-p ((application program-application-mixin) &key force-p)
  (declare (ignore force-p))
  (with-slots (program version-option) application
    (handler-case
        (progn
          (uiop:run-program (list program version-option)
                            :ignore-error-status t
                            :force-shell nil)
          (call-next-method))
      (error (condition)
        (declare (ignore condition))
        nil))))

(defmethod application-version ((application program-application-mixin) &key force-p)
  (declare (ignore force-p))
  (with-slots (version-script) application
    (string-trim '(#\Newline)
                 (uiop:run-program version-script
                                   :ignore-error-status t
                                   :force-shell nil
                                   :output :string
                                   :error-putput :string))))

;;;
;;; simple program mixin
;;;

(defclass simple-program-application-mixin (program-application-mixin)
  ((make-args-fn :initarg :make-args-fn)))

(defun make-simple-program-command (app &rest args)
  (assert (typep app 'simple-program-application-mixin))
  (with-slots (program make-args-fn) app
    (let ((cmd (cons program
                     (apply make-args-fn app
                            (alexandria:remove-from-plist args :error-p :wait-p)))))
      cmd)))

(defun make-simple-program-shell-command (app &rest args)
  (format nil "~{~S ~}" (apply #'make-simple-program-command app args)))

(defun run-simple-program (app &rest args &key wait-p error-p &allow-other-keys)
  (let ((command (apply #'make-simple-program-command app args)))
    (if wait-p
        (multiple-value-bind (output error code)
            (uiop:run-program command :output :string :error-output :string
                                      :force-shell nil
                                      :ignore-error-status (not error-p))
          (if (eql code 0)
              (values (string-trim '(#\Newline) output) t)
              (if error-p
                  (error "error run application ~A" (application-name app))
                  (values (string-trim '(#\Newline) error) nil))))
        (progn
          (uiop:launch-program command
                               :ignore-error-status (not error-p)
                               :force-shell nil)
          (values :backgroud t)))))

(defun run-simple-shell-program (app &rest args &key wait-p error-p &allow-other-keys)
  (let ((command (apply #'make-simple-program-shell-command app args)))
    (if wait-p
        (multiple-value-bind (output error code)
            (uiop:run-program command :output :string :error-output :string
                                      :force-shell t
                                      :ignore-error-status (not error-p))
          (if (eql code 0)
              (values (string-trim '(#\Newline) output) t)
              (values (string-trim '(#\Newline) error) nil)))
        (progn
          (uiop:launch-program command
                               :ignore-error-status (not error-p)
                               :force-shell t)
          (values :backgroud t)))))
